home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
tpu55a.arc
/
TPUNEW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-28
|
48KB
|
1,608 lines
PROGRAM tpunew; {$D+,L+,S+,R-,E-,N-}
USES Dos,Crt,TPUAMS1,TPURPT1,TPUUNA1;
TYPE
SurveyPtr = ^ SurveyRec;
SurveyRec =
RECORD
LocLL : LL; { LL to location of data structure }
LocOwn : LL; { LL to Dictionary Header of Owner or 0 }
LocTyp : Char; { Type of Structure (D,T,H,?) }
END;
SurveyTabPtr = ^ SurveyTab;
SurveyTab =
RECORD
Svy : ARRAY[1..30] OF SurveyRec
END;
MethodName = String[127];
HeadProc = PROCEDURE;
VAR
SurveyQuePtr, SurveyStkPtr : SurveyTabPtr;
SurveyQueMax, SurveyStkMax, SurveyQueTop,
SurveyStkTop, SurveyLimit, SurveySize : Word;
CSegOrg, CSegEnd : Word;
NextLL, LastLL : Word;
TabStop, NoteX, NoteY : Integer;
NoteTime : LongInt;
DisAssembly : Boolean;
SurveyWork : SurveyRec;
PROCEDURE NoteBegin(S:String); {.CP08}
VAR HH,MM,SS,CS : Word;
BEGIN
NoteX := WhereX; NoteY := WhereY; ClrEol;
GetTime(HH,MM,SS,CS);
NoteTime := ((HH*60+MM)*60+SS)*100+CS;
Write(S);
END;
PROCEDURE PageOverFlow(Lines : Word; CallProc : HeadProc);
BEGIN
IF LinesRemaining < Lines THEN
BEGIN
NewTxtPage;
CallProc;
END
ELSE NewTxtLine;
END;
PROCEDURE NoteEnd; {.CP11}
VAR HH,MM,SS,CS : Word; SF : String[3]; I : Integer;
BEGIN
GetTime(HH,MM,SS,CS);
NoteTime := (((HH*60+MM)*60+SS)*100+CS) - NoteTime;
Str(NoteTime MOD 100 + 100:3,SF);
I := NoteTime DIV 100;
Write(', Finished in ',I:5,'.',Copy(SF,2,2),' seconds');
Delay(1000);
GoToXY(NoteX,NoteY);
END;
PROCEDURE PrintTitleBlk(S : String; LinesNeeded : Integer); {.CP11}
BEGIN {PrintTitleBlk}
IF LinesRemaining < LinesNeeded+3
THEN NewTxtPage ELSE SetCol(1);
PutTxt('-------------');
NewTxtLine;
PutTxt('- ' + S);
NewTxtLine;
PutTxt('-------------');
SetCol(1);
END; {PrintTitleBlk}
PROCEDURE PrintAddress(Arg : LL); {.CP06}
BEGIN
IF ColumnsUsed <> 0 THEN NewTxtLine;
PutTxt(HexW(Arg));
SetCol(7);
END; {PrintAddress}
PROCEDURE PrintByteList(U : UnitHeadPtr; Count, Space : Word); {.CP11}
BEGIN
WITH BufPtr(U)^ DO
WHILE Count > 0 DO
BEGIN
PutTxt(HexB(BufByt[NextLL]));
SetCol(ColumnsUsed+Space+1);
Inc(NextLL);
Dec(Count);
END
END; {PrintByteList}
PROCEDURE PrintWd(U : UnitHeadPtr; S : String); {.CP07}
BEGIN
PrintAddress(NextLL);
PrintByteList(U,2,1);
SetCol(TabStop);
PutTxt(S);
END; {PrintWd}
PROCEDURE PrintLL(U : UnitHeadPtr; S : String); {.CP07}
BEGIN
PrintAddress(NextLL);
PrintByteList(U,2,1);
SetCol(TabStop);
PutTxt('LL('+S+')');
END; {PrintLL}
FUNCTION NilLG(U : UnitHeadPtr; Locn : LL) : Boolean; {.CP08}
VAR L : ^LG;
BEGIN
L := Ptr(Seg(U^),Ofs(U^)+Locn); {Get Ptr to LG}
IF (L^.UntLL = 0) AND (L^.UntId = 0)
THEN NilLG := True
ELSE NilLG := False
END;
PROCEDURE PrintLG(U : UnitHeadPtr; S : String); {.CP15}
VAR L : ^LG; V : DictHeadPtr;
BEGIN
IF NOT NilLG(U,NextLL) THEN
BEGIN
L := Ptr(Seg(U^),Ofs(U^)+NextLL); {Get Ptr to LG}
V := AddrLGUnit(U,L^);
IF V <> Nil THEN S := S + ' in "'+V^.DSymb+'" unit';
S := 'LG('+S+')';
END;
PrintAddress(NextLL);
PrintByteList(U,4,1);
SetCol(TabStop);
PutTxt(S);
END; {PrintLG}
PROCEDURE PrintSoloByte(U : UnitHeadPtr; S : String); {.CP08}
VAR B : Byte;
BEGIN
PrintAddress(NextLL);
PrintByteList(U,1,0);
SetCol(TabStop);
PutTxt(S);
END; {PrintSoloByte}
PROCEDURE PrintBytes(U : UnitHeadPtr; Count, Limit : Word); {.CP12}
VAR I : Integer;
BEGIN
I := 0;
WITH BufPtr(U)^ DO WHILE Count > 0 DO BEGIN
I := I MOD Limit;
IF I = 0 THEN PrintAddress(NextLL);
PrintByteList(U,1,1);
Inc(I);
Dec(Count);
END;
END; {PrintBytes}
PROCEDURE BoundaryAlign(UH : UnitHeadPtr); {.CP12}
VAR I : Integer;
BEGIN {BoundaryAlign}
I := ((NextLL + 15) AND $FFF0) - NextLL;
IF I > 0 THEN
BEGIN
PrintBytes(UH,I,8);
SetCol(36);
PutTxt('Align to Paragraph Boundary');
NewTxtLine
END;
END; {BoundaryAlign}
PROCEDURE PrintOffset(Base: Word); {.CP05}
BEGIN
PrintAddress(NextLL);
PutTxt('[+'+HexW(NextLL-Base)+']: ');
END;
PROCEDURE PrintCodeBytes(U : UnitHeadPtr; Count,Limit,Base: Word); {.CP12}
VAR I : Integer;
BEGIN
I := 0;
WITH BufPtr(U)^ DO WHILE Count > 0 DO BEGIN
I := I MOD Limit;
IF I = 0 THEN PrintOffset(Base);
PrintByteList(U,1,1);
Inc(I);
Dec(Count);
END;
END; {PrintBytes}
PROCEDURE PrintUnknowns(U : UnitHeadPtr; Till:LL); {.CP06}
BEGIN {PrintUnknowns}
PrintTitleBlk('The Purpose of the data below is Unknown',1);
PrintBytes(U,Till-NextLL,8);
NewTxtLine;
END; {PrintUnknowns}
PROCEDURE FormatHeader(U : UnitHeadPtr); {.CP37}
VAR I : Integer;
BEGIN
NoteBegin('Formatting Unit Header');
PrintAddress(NextLL);
FOR I := 0 TO 3 DO PutTxt(HexB(Byte(U^.FilHd[I]))+' ');
SetCol(TabStop);
PutTxt('=''');
FOR I := 0 TO 3 DO PutTxt(U^.FilHd[I]);
PutTxt('''');
NewTxtLine;
Inc(NextLL,4);
PrintAddress(NextLL);
FOR I := 0 TO 3 DO PutTxt(HexB(Byte(U^.Fillr[I]))+' ');
NewTxtLine;
Inc(NextLL,4);
PrintLL(U,'Dict Entry-This Unit');
PrintLL(U,'Interface Hash Table');
PrintLL(U,'PROC Map');
PrintLL(U,'CSeg Map');
PrintLL(U,'DSeg Map-Typed CONSTs');
PrintLL(U,'DSeg Map-Global VARs');
PrintLL(U,'List of Donor Units');
PrintLL(U,'List of Source Files');
PrintLL(U,'Debug TRACE Step Controls');
PrintLL(U,'end NON-CODE part of Unit');
PrintWd(U,'Size of Code in CSeg''s');
PrintWd(U,'Size of CONST Data in DSeg''s');
PrintWd(U,'Size of Relocation List');
PrintWd(U,'unknown function (VIRTUAL Methods?)');
PrintWd(U,'Size of Global VARs in DSeg''s');
PrintLL(U,'DEBUG Hash Table');
PrintWd(U,'Flags Overlay if non-zero ?');
NewTxtLine;
IF NextLL < U^.UGHsh THEN PrintUnknowns(U,U^.UGHsh);
NoteEnd;
END; {FormatHeader}
FUNCTION NameOfMethod(U:UnitHeadPtr;UsrDE:LL):MethodName; {.CP20}
VAR DS, DC : DictHeadPtr; S : DictStubPtr; T : TypePtr; N, M : String[64];
BEGIN
N := ''; M := '???';
IF UsrDE <> $FFFF THEN
BEGIN
DS := DictHeadPtr(PtrAdjust(U,UsrDE));
M := DS^.DSymb;
S := AddrStub(DS);
IF DS^.DForm = 'S' THEN {ensure subprogram entry}
IF (S^.TCod AND $10) <> 0 THEN {get OBJECT Name Qualifier}
IF S^.Scop <> 0 THEN
BEGIN
T := TypePtr(PtrAdjust(U,S^.Scop)); {to Object TD}
DC := DictHeadPtr(PtrAdjust(U,T^.ObjtName)); {to Object DE}
N := DC^.Dsymb+'.';
END
END;
NameOfMethod := N + M
END; {NameOfMethod}
PROCEDURE FormatDictionary(U : UnitHeadPtr); {.CP16}
PROCEDURE PrintDictEntry;
VAR D,DB : DictHeadPtr; S : DictStubPtr; I : Integer; T : String[44];
W : String;
BEGIN {PrintDictEntry}
D := AddrDict(U,SurveyWork.LocLL); S := AddrStub(D);
WITH SurveyWork, D^, S^ DO BEGIN
I := 4+(Length(DSymb) SHR 4);
CASE DForm OF
'O','T','U','V',
'W','Q','X': Inc(I);
'P': Inc(I,2);
'Y','R': Inc(I,4); 'S': Inc(I,6);
END; {CASE}
W := ''; {.CP12}
IF DForm = 'R' THEN
IF RH = 8 THEN
IF SurveyWork.LocOwn <> 0
THEN W := NameOfMethod(U,SurveyWork.LocOwn)
ELSE
ELSE
IF ROB <> 0 THEN W := NameOfMethod(U,ROB);
IF W = '???' THEN W := '' ELSE
IF W <> '' THEN W := W + '.';
PrintTitleBlk('Dictionary Entry For: "'+ W +
NameOfMethod(U,SurveyWork.LocLL)+'"',I);
IF HLink <> 0 {.CP24}
THEN PrintLL(U,AddrDict(U,HLink)^.DSymb)
ELSE PrintWd(U,'(no backward link)');
PrintBytes(U,1,1);
SetCol(TabStop);
PutTxt('Type "'+DForm+'" -> ');
CASE DForm OF {.CP18}
'O': PutTxt('GOTO Label'); 'P': PutTxt('Constant');
'Y': PutTxt('Unit'); 'T': PutTxt('Built-In Procedure');
'W': PutTxt('Port Array'); 'U': PutTxt('Built-In Function');
'Q': PutTxt('Named Type'); 'V': PutTxt('Built-In "NEW"');
'X': PutTxt('External VAR');
'R': CASE RH OF
$0: PutTxt('Global VAR');
$1: PutTxt('Typed CONST');
$2: PutTxt('VAR (VALUE on Stack)');
$6: PutTxt('VAR (ADDRESS on Stack)');
$8: PutTxt('Record/Object Field');
END; {CASE RH}
'S': PutTxt('User Subprogram/Method');
END; {CASE DForm OF}
PrintBytes(U,Length(DSymb)+1,16);
SetCol(TabStop); PutTxt('="'+DSymb+'"');
NewTxtLine;
CASE DForm OF { Format the Stub Part } {.CP13}
'O': PrintWd(U,'Code Offset for Jump???)');
'P': BEGIN
PrintLG(U,'type descriptor');
PrintBytes(U,LastLL-NextLL,8); {Temporary Fix}
{since value can be a string, we really need to check
the type descriptor out but that usually lies in the
system unit. We circumvent for now by relying on the
distance to the next structure to determine the size
of the constant data for print purposes }
SetCol(TabStop); PutTxt('Constant Value');
NewTxtLine;
END; {CASE 'P'}
'Y': BEGIN {.CP07}
PrintWd(U,'TURBO Work?');
PrintWd(U,'unknown purpose-signature???');
PrintLL(U,'next unit in list');
PrintLL(U,'prior unit in list');
NewTxtLine;
END; {CASE 'Y'}
'T','U','V': BEGIN {.CP4}
PrintWd(U,'unknown purpose');
NewTxtLine;
END;
'W': BEGIN {.CP4}
PrintSoloByte(U,'0=byte array, 1=word array');
NewTxtLine;
END;
'Q','X': BEGIN {.CP4}
PrintLG(U,'type descriptor');
NewTxtLine;
END;
'R': BEGIN {.CP32}
CASE RH OF
$0: T := 'Global VAR in DS';
$1: T := 'Typed CONST in DS';
$2: IF ROfs > $7FFF
THEN T := 'Local Variable on Stack'
ELSE T := 'Parameter VALUE on Stack';
$6: T := 'Parameter ADDR on Stack';
$8: T := 'Record/Object Field'
ELSE T := '**** NEW CODE TO CHECK ****'
END; {CASE RH}
PrintSoloByte(U,T);
T := '';
IF (RH = $2) OR (RH = $6) THEN
IF ROfs > $7FFF
THEN T := 'BP-'+HexW($10000-ROfs)
ELSE T := 'BP+'+HexW(ROfs)
ELSE T := 'bytes';
PrintWd(U,'allocation offset ('+T+')');
CASE RH OF
$0,$2,$6: IF ROB = 0
THEN T := 'no containing scope'
ELSE T := 'LL(containing Scope)';
$1: T := 'offset to DSeg Map Entry';
$8: IF ROB = 0
THEN T := 'no successor field/method'
ELSE T := 'LL(successor field/method)';
ELSE T := 'unknown purpose'
END; {CASE RH}
PrintWd(U,T);
PrintLG(U,'type descriptor');
END; {CASE 'R'}
'S': BEGIN {.CP36}
T := '';
IF TCod = $00 THEN T := '+Nested PROC' ELSE
IF (TCod AND $10) <> 0 THEN
CASE (TCod AND $60) OF
$00: T := '+Method'; $20: T := '+Constructor';
$40: T := '+Destructor';
ELSE T := '+Method?'
END;
IF (TCod AND $08) <> 0 THEN T := T + '+EXTERNAL';
IF (TCod AND $01) <> 0 THEN T := T + '+INTERFACE';
IF (TCod AND $02) <> 0 THEN T := T + '+INLINE';
IF Length(T) > 0 THEN Delete(T,1,1);
PrintSoloByte(U,T);
IF (TCod AND $02) <> 0 THEN T := 'INLINE Code Bytes'
ELSE T := 'offset in PROC Map';
PrintWd(U,T);
IF Scop = 0 THEN T := 'no containing scope'
ELSE T := 'LL(containing scope)';
PrintWd(U,T);
IF SHsh = 0 THEN T := 'no local Hash Table'
ELSE T := 'LL(local scope Hash Table)';
PrintWd(U,T);
IF (SVMO <> 0) AND (SVMO <> $FFFF)
THEN T := 'Method PTR offset in VMT'
ELSE T := 'not a VIRTUAL Method';
PrintWd(U,T);
IF Smth = 0 THEN T := 'no successor Methods'
ELSE T := 'LL(Next Method for Object)';
PrintWd(U,T);
SetCol(1);
END; {CASE 'S'}
END; {CASE DForm OF}
END; {WITH}
END; {PrintDictEntry}
PROCEDURE PrintTypeEntry; {.CP46}
VAR T : TypePtr; W : String[64]; D : DictHeadPtr; I : Integer;
BEGIN {PrintTypeEntry}
T := TypePtr(PtrAdjust(U,SurveyWork.LocLL));
I := 0;
CASE T^.Typ OF
$01, $02, $09: I := 2; $04, $05, $07, $08: I := 1;
$0C..$0F: I := 3; $03: I := 10; $06: I := 7 + 2*T^.PNPrm;
END; {CASE}
W := '';
IF SurveyWork.LocOwn <> 0
THEN W := NameOfMethod(U,SurveyWork.LocOwn)
ELSE
IF T^.Typ = $03
THEN W := NameOfMethod(U,T^.ObjtName);
IF (W <> '') AND (W <> '???') THEN W := ' For: "' + W + '"';
PrintTitleBlk('Type Descriptor' + W,I+2);
WITH T^ DO BEGIN
PrintBytes(U,2,8);SetCol(TabStop);
CASE Typ OF
$00: W := 'un-typed'; $01: W := 'Array';
$02: W := 'Record'; $03: W := 'Object';
$04: W := 'File'; $05: W := 'Text';
$06: W := 'Procedure'; $07: W := 'Set';
$08: W := 'Pointer'; $09: W := 'String';
$0A: CASE TMod OF
$00: W := 'Single'; $02: W := 'Extended';
$04: W := 'Double'; $06: W := 'Comp';
ELSE W := '8087-Floating?'
END; {CASE TMod}
$0B: W := 'Real';
$0C: CASE TMod OF
$00: W := 'un-named byte integer'; $01: W := 'ShortInt';
$02: W := 'Byte'; $04: W := 'un-named word integer';
$05: W := 'Integer'; $06: W := 'Word';
$0C: W := 'un-named double-word integer';
$0D: W := 'LongInt';
ELSE W := 'unknown integer type';
END; {CASE TMod}
$0D: W := 'Boolean'; $0E: W := 'Char';
$0F: W := 'enumeration';
ELSE W := 'unknown type code';
END; {CASE Typ OF}
PutTxt('Type='+W);
PrintWd(U,'Storage Width (bytes)');
CASE Typ OF {.CP05}
$01: BEGIN
PrintLG(U,'Base Type Desc');
PrintLG(U,'Array Bounds');
END;
$02: BEGIN {.CP04}
PrintLL(U,'Field List Hash Table');
PrintLL(U,'Dict Entry of 1st Field');
END;
$03: BEGIN {.CP17}
PrintLL(U,'Field/Method Hash Table');
PrintLL(U,'Field/Method Dictionary');
WITH ObjtOwnr DO
IF NilLG(U,NextLL)
THEN PrintLG(U,'nothing inherited')
ELSE PrintLG(U,'ancestor Object Desc');
PrintWd(U,'Size of VMT (bytes)');
IF ObjtDMap = $FFFF
THEN PrintWd(U,'there is no VMT')
ELSE PrintWd(U,'DSeg Map Offset of VMT Skeleton');
IF ObjtVMTO = $FFFF
THEN PrintWd(U,'Object has no VIRTUAL Methods')
ELSE PrintWd(U,'Offset in Object to VMT Pointer');
D := AddrDict(U,ObjtName);
PrintLL(U,'Dict Entry ('+D^.DSymb+')');
END;
$06: BEGIN {.CP21}
IF NilLG(U,NextLL)
THEN PrintLG(U,'Procedures have no Function Result')
ELSE PrintLG(U,'Function Result Type');
IF PNPrm = 0 THEN PrintWd(U,'no parameter list') ELSE
BEGIN
Str(PNPrm,W); W := W + ' Formal Parameter';
IF PNPrm > 1 THEN W := W + 's';
PrintWd(U,W);
FOR I := 1 TO PNPrm DO WITH PFPar[I] DO BEGIN
Str(I,W);
PrintLG(U,'Parm ' + W + ' TypDesc');
IF ALM = $02
THEN W := 'Pass VALUE on Stack'
ELSE IF ALM = $06
THEN W := 'Pass ADDRESS on Stack'
ELSE W := '**** NEW CODE VALUE ***';
PrintSoloByte(U,W)
END; {FOR}
END;
END; { CASE $06 }
$04.. {.CP20}
$05: PrintLG(U,'Base File TypeDesc');
$07: PrintLG(U,'Base Set TypeDesc');
$08: PrintLG(U,'Base Ptr TypeDesc');
$09: BEGIN
PrintLG(U,'Type[array of char]');
PrintLG(U,'Array Bounds TypeDesc');
END;
$0C.. {.CP12}
$0F: BEGIN
PrintBytes(U,SizeOf(T^.LoBnd),8);
SetCol(TabStop);PutTxt('Subrange Lower Bound');
PrintBytes(U,SizeOf(T^.HiBnd),8);
SetCol(TabStop);PutTxt('Subrange Upper Bound');
PrintLG(U,'Upward Compat TypeDesc');
END; { $0C,$0D,$0E,$0F}
END; {CASE Typ OF}
END; {WITH}
END; {PrintTypeEntry}
PROCEDURE PrintHashEntry; {.CP22}
VAR H : HashPtr;
FUNCTION PrintEmptyHash(Bot,Top:Word):Word;
VAR I, J, K : Word;
BEGIN
I := Bot;
WITH H^ DO REPEAT
IF Slt[I] = 0
THEN Inc(I)
ELSE Top := I-1;
UNTIL Top < I;
K := 0;
WITH H^ DO FOR J := Bot TO Top DO BEGIN
IF (K AND $3)=0 THEN PrintAddress(NextLL);
PutTxt(HexB(LO(Slt[J]))+' ');
PutTxt(HexB(HI(Slt[J]))+' ');
Inc(NextLL,2);
Inc(K);
END;
PrintEmptyHash := I
END; {PrintEmptyHash}
VAR D : DictHeadPtr; I, J, K, N : Word; W : String[44]; {.CP26}
BEGIN {PrintHashEntry}
H := AddrHash(U,SurveyWork.LocLL);
N := H^.Bas DIV 2;
W := '';
IF SurveyWork.LocLL = U^.UGHsh
THEN W := '- INTERFACE Dictionary' ELSE
IF SurveyWork.LocLL = U^.UHash2
THEN W := '- Turbo DEBUG Dictionary' ELSE
IF SurveyWork.LocOwn <> 0
THEN W := 'Owned By: "'+NameOfMethod(U,SurveyWork.LocOwn)+'"';
PrintTitleBlk('Hash Table '+W,3);
PrintWd(U,'Bytes in Hash Table - 2');
SetCol(1);PutTxt('----');
I := 0;
WITH H^ DO REPEAT
IF Slt[I] <> 0 THEN
BEGIN
PrintLL(U,AddrDict(U,Slt[I])^.DSymb);
Inc(I)
END ELSE I := PrintEmptyHash(I,N);
UNTIL I > N;
NewTxtLine;
END; {PrintHashEntry}
PROCEDURE PrintInLineEntry; {.CP15}
VAR D : DictHeadPtr; S : DictStubPtr; I : Integer; T : TypePtr;
BEGIN {PrintInLineEntry}
D := AddrDict(U,SurveyWork.LocOwn); { Procedure Header }
S := AddrStub(D); { Procedure Stub }
T := AddrProcType(S); { Type Descriptor }
WITH SurveyWork, T^ DO BEGIN
I := (S^.BCod+15) SHR 4;
PrintTitleBlk('INLINE Code Bytes FOR: "'+
NameOfMethod(U,SurveyWork.LocOwn)+'"',I);
PrintBytes(U,S^.BCod,16);
SetCol(1);
END;
END; {PrintInLineEntry}
VAR I : Word; BU : SurveyRec; DoneHash : Boolean; BUL : LL; {.CP27}
BEGIN {FormatDictionary}
NoteBegin('Formatting Dictionary');
DoneHash := False;
WITH SurveyWork DO
FOR I := 1 TO SurveyQueTop DO BEGIN
SurveyWork := SurveyQuePtr^.Svy[I];
IF I < SurveyQueTop
THEN LastLL := SurveyQuePtr^.Svy[I+1].LocLL
ELSE LastLL := U^.UHPrc;
BU := SurveyWork;
IF NextLL < LocLL THEN
IF NOT DoneHash THEN PrintUnknowns(U,LocLL) ELSE
BEGIN
BUL := LastLL;
LocLL := NextLL; LastLL := BU.LocLL;
LocOwn := 0; LocTyp := 'T';
PrintTypeEntry;
SurveyWork := BU; LastLL := BUL;
END;
CASE LocTyp OF
'D': PrintDictEntry;
'T': PrintTypeEntry;
'H': BEGIN PrintHashEntry; DoneHash := True END;
'I': PrintInLineEntry;
END; {CASE}
END; {FOR}
IF NextLL < U^.UHPrc THEN PrintUnknowns(U,U^.UHPrc); {.CP9}
FreeMem(SurveyQuePtr,SurveySize);
FreeMem(SurveyStkPtr,SurveySize);
SurveyQuePtr := Nil;
SurveyStkPtr := Nil;
SurveyQueTop := 0;
SurveyStkTop := 0;
NoteEnd;
END; {FormatDictionary}
FUNCTION SearchSurveyQue(Locn : LL):Word; {.CP17}
VAR Lo, Mid, Hi : Word;
BEGIN
IF SurveyQueTop < 1 THEN SearchSurveyQue := 1 ELSE
WITH SurveyQuePtr ^ DO
BEGIN
Lo := 1; Hi := SurveyQueTop;
REPEAT
Mid := Longint(Lo + Hi) SHR 1;
IF Locn > Svy[Mid].LocLL
THEN Lo := Mid + 1
ELSE Hi := Mid - 1
UNTIL (Svy[Mid].LocLL=Locn) OR (Lo > Hi);
IF Locn > Svy[Mid].LocLL THEN Mid := Mid+1;
SearchSurveyQue := Mid;
END; {WITH}
END; {SearchSurveyQue}
PROCEDURE AddToSurveyQue(U : UnitHeadPtr; Arg : SurveyRec); {.CP23}
VAR I, Key : LL;
BEGIN
Key := SearchSurveyQue(Arg.LocLL);
IF Arg.LocLL < U^.UHPrc THEN
WITH SurveyQuePtr^ DO
IF Key > SurveyQueTop THEN
BEGIN
SurveyQueTop := SurveyQueTop + 1;
Svy[SurveyQueTop] := Arg
END ELSE
IF Arg.LocLL <> Svy[Key].LocLL THEN
BEGIN
SurveyQueTop := SurveyQueTop + 1;
FOR I := SurveyQueTop DownTo Key+1 DO
Svy[I] := Svy[I-1];
Svy[Key] := Arg
END;
WITH SurveyQuePtr^ DO
IF Svy[Key].LocOwn = 0 THEN Svy[Key].LocOwn := Arg.LocOwn;
IF SurveyQueTop > SurveyQueMax THEN SurveyQueMax := SurveyQueTop;
END; {AddToSurveyQue}
PROCEDURE AddToSurveyStk(U : UnitHeadPtr; ArgLoc,ArgOwn:LL; ArgTyp:Char);{.CP13}
VAR Arg : SurveyRec;
BEGIN
Arg.LocLL := ArgLoc; Arg.LocOwn := ArgOwn; Arg.LocTyp := ArgTyp;
WITH SurveyStkPtr^ DO
BEGIN
SurveyStkTop := SurveyStkTop + 1;
IF SurveyStkTop > SurveyStkMax
THEN SurveyStkMax := SurveyStkTop;
Svy[SurveyStkTop] := Arg
END
END; {AddToSurveyStk}
PROCEDURE PopFromSurveyStk(VAR Arg : SurveyRec); {.CP05}
BEGIN
Arg := SurveyStkPtr^.Svy[SurveyStkTop];
Dec(SurveyStkTop);
END; {PopFromSurveyStk}
FUNCTION IsInSurveyQue(Key : LL):Boolean; {.CP11}
VAR Loc : Word;
BEGIN
Loc := SearchSurveyQue(Key);
IF Loc > SurveyQueTop
THEN IsInSurveyQue := False
ELSE
IF Key = SurveyQuePtr^.Svy[Loc].LocLL
THEN IsInSurveyQue := True
ELSE IsInSurveyQue := False
END; {IsInSurveyQue}
PROCEDURE SurveyDictionary(U:UnitHeadPtr); {.CP03}
PROCEDURE SurveyWrapUp;
PROCEDURE SurveyWrapPost(x,s:LL); {.CP09}
VAR J : LL;
BEGIN
j := SearchSurveyQue(s);
WITH SurveyQuePtr^.Svy[j] DO
IF LocLL = s THEN
IF (LocOwn > x) OR (LocOwn = 0)
THEN LocOwn := x;
END;
PROCEDURE SurveyWrapType(x : LL); {.CP26}
VAR D : DictHeadPtr; S : DictStubPtr; T : TypePtr; i,j,k : LL;
BEGIN
D := AddrDict(U,x); { Q entry }
S := AddrStub(D); { its stub }
T := AddrType(U,S^.QTG);
IF T <> Nil THEN { TD in this unit }
BEGIN
SurveyWrapPost(x,S^.QTG.UntLL);
IF (T^.Typ = 2) OR (T^.Typ = 3) THEN
BEGIN
i := T^.RecdDict;
IF i <> x THEN
WHILE i <> 0 DO BEGIN
SurveyWrapPost(x,i);
D := AddrDict(U,i);
S := AddrStub(D);
IF D^.DForm = 'R'
THEN i := S^.ROB ELSE
IF D^.DForm = 'S'
THEN i := S^.Smth
ELSE i := 0;
END
END
END
END; {SurveyWrapType}
VAR i : Integer; {.CP08}
BEGIN
For i := 1 TO SurveyQueTop DO
WITH SurveyQuePtr^.Svy[i] DO
IF LocTyp = 'D' THEN
IF AddrDict(U,LocLL)^.DForm = 'Q'
THEN SurveyWrapType(LocLL)
END; {SurveyWrapUp}
PROCEDURE SurveyType(Arg : SurveyRec); {.CP52}
VAR T, TT : TypePtr; H:HashPtr; TTL : LL; I : Integer;
BEGIN {SurveyType}
T := TypePtr(PtrAdjust(U,Arg.LocLL));
TTL := Arg.LocLL;
IF T <> Nil THEN
WITH T^ DO
CASE Typ OF
$01: BEGIN
IF AddrType(U,BaseType) <> Nil
THEN AddToSurveyStk(U,BaseType.UntLL,0,'T');
IF AddrType(U,BounDesc) <> Nil
THEN AddToSurveyStk(U,BounDesc.UntLL,0,'T');
END; {CASE $01}
$02: IF RecdHash <> 0 THEN
AddToSurveyStk(U,RecdHash,Arg.LocOwn,'H');
$03: IF ObjtHash <> 0 THEN
AddToSurveyStk(U,ObjtHash,ObjtName,'H');
$04,
$05: IF AddrType(U,FileType) <> Nil THEN
AddToSurveyStk(U,FileType.UntLL,0,'T');
$06: BEGIN
IF AddrType(U,T^.PFRes) <> Nil THEN
AddToSurveyStk(U,T^.PFRes.UntLL,Arg.LocOwn,'T');
{ Handle Parameter List Entries Here }
FOR I := 1 TO T^.PNPrm DO WITH T^.PFPar[I] DO
IF AddrType(U,TDG) <> Nil THEN
AddToSurveyStk(U,TDG.UntLL,Arg.LocOwn,'T');
END; {CASE $06}
$07: IF AddrType(U,SetBase) <> Nil THEN
AddToSurveyStk(U,SetBase.UntLL,0,'T');
$08: IF AddrType(U,PtrBase) <> Nil THEN
AddToSurveyStk(U,PtrBase.UntLL,0,'T');
$09: BEGIN
IF AddrType(U,StrBase) <> Nil THEN
AddToSurveyStk(U,StrBase.UntLL,0,'T');
IF AddrType(U,StrBound) <> Nil THEN
AddToSurveyStk(U,StrBound.UntLL,0,'T');
END; {CASE $09}
$0C,
$0D,
$0E: IF AddrType(U,Cmpat) <> Nil THEN
AddToSurveyStk(U,Cmpat.UntLL,0,'T');
$0F: BEGIN {.CP09}
IF AddrType(U,Cmpat) <> Nil THEN
AddToSurveyStk(U,Cmpat.UntLL,0,'T');
{ now stack the SET descriptor that follows }
TT := TypePtr(PtrAdjust(@Cmpat,SizeOf(T^.Cmpat)));
AddToSurveyStk(U,FormLL(U,TT),0,'T');
END; {CASE $0F}
END; {CASE Typ}
END; {SurveyType}
PROCEDURE SurveyDictStub(D : DictHeadPtr; {.CP39}
S : DictStubPtr; Owner : LL);
VAR T : TypePtr; H : HashPtr; I : Integer; LLDE : LL; C : Char;
BEGIN {SurveyDictStub}
C := D^.DForm;
LLDE := FormLL(U,D);
WITH S^ DO
CASE C OF
'P': IF AddrType(U,DTG) <> Nil THEN
AddToSurveyStk(U,DTG.UntLL,0,'T');
'Q': IF AddrType(U,QTG) <> Nil THEN
AddToSurveyStk(U,QTG.UntLL,LLDE,'T');
'X': IF AddrType(U,QTG) <> Nil THEN
AddToSurveyStk(U,QTG.UntLL,0,'T');
'R': IF AddrType(U,RLG) <> Nil THEN
AddToSurveyStk(U,RLG.UntLL,0,'T');
'S': BEGIN
IF SHsh <> 0 THEN AddToSurveyStk(U,SHsh,LLDE,'H');
T := AddrProcType(S);
AddToSurveyStk(U,FormLL(T,U),LLDE,'T');
IF AddrType(U,T^.PFRes) <> Nil THEN
AddToSurveyStk(U,T^.PFRes.UntLL,0,'T');
{ Handle Parameter List Entries Here }
FOR I := 1 TO T^.PNPrm DO WITH T^.PFPar[I] DO
IF AddrType(U,TDG) <> Nil THEN
AddToSurveyStk(U,TDG.UntLL,0,'T');
IF (TCod AND $02) <> 0 THEN
AddToSurveyStk(U,FormLL(U,@T^.PFPar[T^.PNPrm+1]),LLDE,'I');
END; {CASE 'S'}
'Y': BEGIN {.CP07}
IF UA <> 0 THEN AddToSurveyStk(U,UA,0,'D');
IF UZ <> 0 THEN AddToSurveyStk(U,UZ,0,'D');
END; {CASE 'Y'}
END; {CASE D^.DForm}
END; {SurveyDictStub}
PROCEDURE SurveyDictHdr(Arg : SurveyRec); {.CP09}
VAR D : DictHeadPtr; S : DictStubPtr;
BEGIN {SurveyDictHdr}
D := AddrDict(U,Arg.LocLL);
S := AddrStub(D);
SurveyDictStub(D,S,Arg.LocLL);
IF D^.HLink <> 0 THEN
AddToSurveyStk(U,D^.HLink,0,'D');
END; {SurveyDictHdr}
PROCEDURE SurveyHashTab(Arg : SurveyRec); {.CP08}
VAR HLim, I : LL; H : HashPtr;
BEGIN {SurveyHashTab}
H := AddrHash(U,Arg.LocLL);
HLim := (H^.Bas DIV SizeOf(LL));
WITH H^ DO FOR I := 0 TO HLim DO
IF Slt[I] <> 0 THEN AddToSurveyStk(U,Slt[I],Arg.LocOwn,'D');
END; {SurveyHashTab}
BEGIN {SurveyDictionary} {.CP33}
NoteBegin('Surveying Dictionary');
SurveySize := (U^.UHPrc-U^.UGHsh) + SizeOf(SurveyRec) - 1;
SurveySize := SurveySize-(SurveySize MOD SizeOf(SurveyRec));
GetMem(SurveyQuePtr,SurveySize);
GetMem(SurveyStkPtr,SurveySize);
SurveyLimit := SurveySize DIV SizeOf(SurveyRec);
SurveyQueTop := 0; SurveyQueMax := 0;
SurveyStkTop := 0; SurveyStkMax := 0;
WITH U^ DO BEGIN
AddToSurveyStk(U,UGHsh,UDirE,'H'); { INTERFACE Hash Table }
AddToSurveyStk(U,UDirE,0,'D'); { Unit Dictionary Entry }
IF UGHsh <> UHash2 THEN
AddToSurveyStk(U,UHash2,UHash2,'H'); { Debug Rtn Hash Table }
END;
WITH SurveyWork DO
WHILE SurveyStkTop > 0 DO BEGIN
PopFromSurveyStk(SurveyWork);
IF NOT IsInSurveyQue(LocLL) THEN
BEGIN
AddToSurveyQue(U,SurveyWork);
CASE LocTyp OF
'D': SurveyDictHdr(SurveyWork);
'H': SurveyHashTab(SurveyWork);
'T': SurveyType(SurveyWork);
END; {CASE}
END; {IF}
END; {WHILE}
SurveyWrapUp; {Resolve Type Descriptor Names}
NoteEnd;
END; {SurveyDictionary}
FUNCTION NameOfObject(U:UnitHeadPtr;UsrDE:LL):LexNam; {.CP15}
VAR D : DictHeadPtr; T : TypePtr;
BEGIN
IF UsrDE = $0000 THEN NameOfObject := '???' ELSE
BEGIN
T := TypePtr(PtrAdjust(U,UsrDE)); {to Object TD}
D := Nil;
IF T^.Typ = $03 THEN
BEGIN
D := DictHeadPtr(PtrAdjust(U,T^.ObjtName)); {to Object DE}
NameOfObject := D^.Dsymb
END ELSE
NameOfObject := '???'
END
END; {NameOfObject}
{$F+}
PROCEDURE CSegHeadings; {.CP09}
BEGIN
SetCol(8);
PutTxt('Entry Turbo Segmt Relo Trace : Source File Load 1''st n''th');
SetCol(8);
PutTxt('Offset Work? Bytes Bytes Entry : For CODE Seg ADDR Relo Relo');
SetCol(8);
PutTxt('------ ----- ----- ----- ----- : ------------ ---- ---- ----');
END; {CSegHeadings}{$F-}
PROCEDURE FormatCSegMap(UPt:UnitHeadPtr; {.CP23}
VAR PE:PMapRefTab;PELim:Word;
VAR CE:CMapRefTab;CELim:Word);
VAR C : CSegMapTabPtr; SF : SrcFilePtr;
D : DictHeadPtr; T : TypePtr;
I, J, K, OldTabSet, Base, RBase : Word;
BEGIN
NoteBegin('Formatting CSeg Map');
OldTabSet := TabStop;
TabStop := 42;
RBase := (UPt^.UndNC + $F) AND $FFF0;
RBase := (UPt^.ULCod + $F) AND $FFF0 + RBase;
RBase := (UPt^.ULTCon + $F) AND $FFF0 + RBase;
IF NMapC > 0 THEN { make sure CSeg Map non-empty } {.CP33}
BEGIN
PrintTitleBlk('CSeg Map Table Begins Here (LL at 000E)',7);
NextLL := Upt^.UHCsg;
I := 0;
K := 0;
CSegHeadings; Base := NextLL;
REPEAT
PageOverFlow(6,CSegHeadings);
SF := AddrSrcTabOff(UPt,CE.CmRefs[I].CmNdxF);
PrintCodeBytes(UPt,8,8,Base);
SetCol(TabStop);
PutTxt(SF^.SrcName);
SetCol(TabStop+14);
PutTxt(HexW(CE.CmRefs[i].CmSegL)+' ');
IF CE.CmRefs[i].CmNdxR <= CE.CmRefs[i].CmCntR THEN
BEGIN
j := CE.CmRefs[i].CmNdxR;
PutTxt(HexW(RBase+SizeOf(ReloListEntry)*j)+' ');
j := CE.CmRefs[i].CmCntR;
PutTxt(HexW(RBase+SizeOf(ReloListEntry)*j));
END;
I := I + 1;
UNTIL I > CELim-1;
END;
TabStop := OldTabSet;
NoteEnd;
END; { FormatCSegMap }
{$F+}
PROCEDURE ProcHeadings;
BEGIN
SetCol(8); PutTxt('Entry CSeg PROC : Jump Byte Name Of');
SetCol(8); PutTxt('Offset Map^ Ofset : Addr Cnt Procedure');
SetCol(8); PutTxt('------ ----- ----- : ---- ---- ----------');
END; {ProcHeadings}{$F-}
PROCEDURE FormatProcMap(UPt:UnitHeadPtr;VAR PE:ProcMapTab;Limit:Word); {.CP10}
TYPE V = ARRAY[0..1] OF Word; Vector = ^V;
FUNCTION UnravelPMapSort:Vector; {.CP11}
VAR VP : Vector; i : Word;
BEGIN
IF PMapP = Nil THEN VP := Nil ELSE
BEGIN
GetMem(VP,NMapP*SizeOf(WORD));
FOR i := 0 TO NMapP-1 DO WITH PMapP^.PMRefs[i] DO
VP^[PmNdxP] := i;
END;
UnravelPMapSort := VP
END; {UnravelPMapSort}
VAR Base, I, J, OldTabStop : Word; VP : Vector; {.CP25}
BEGIN {FormatProcMap}
NoteBegin('Formatting PROC Map');
OldTabStop := TabStop;
TabStop := 30;
SetCol(1);
VP := UnravelPMapSort;
IF CountPMapSlots(UPt) > 0 THEN { Make Sure PROC Map not empty }
BEGIN
PrintTitleBlk('PROC Map Table Begins Here (LL at 000C)',7);
NextLL := Upt^.UHPrc;
I := 0; Base := NextLL;
ProcHeadings;
WITH PMapP^,UPt^ DO REPEAT
PageOverFlow(3,PROCHeadings);
PrintCodeBytes(UPt,4,4,Base);
SetCol(TabStop);
PutTxt(HexW(PmRefs[VP^[i]].PmEntP)+' ');
PutTxt(HexW(PmRefs[VP^[i]].PmSizP)+' ');
IF I = 0 THEN
IF ProcMapPtr(PtrAdjust(UPt,UHPrc))^.ProcMap[0].CSegOfs = $FFFF
THEN PutTxt('Not Used (No Unit Init Code)')
ELSE PutTxt('Unit Initialization Code')
ELSE PutTxt(NameOfMethod(UPt,PmRefs[VP^[i]].PmDirN));
I := I + 1;
UNTIL NextLL >= UHCsg;
END;
FreeMem(VP,NMapP*SizeOf(Word));
TabStop := OldTabStop;
NoteEnd;
END; {FormatProcMap}
{$F+}
PROCEDURE CONSTHeadings;
BEGIN
SetCol(8); PutTxt('Entry Turbo Segmt Relo VMT ');
SetCol(8); PutTxt('Offset Work? Bytes Bytes Owner');
SetCol(8); PutTxt('------ ----- ----- ----- -----');
END; {CONSTHeadings}{$F-}
PROCEDURE FormatTypedConMap(UPt:UnitHeadPtr); {.CP42}
VAR C : DSegMapTabPtr; Wk : Str4; I, J, K : Integer; T:TypePtr;
Base : Word;
BEGIN { FormatTypedConMap }
NoteBegin('Formatting CONST DSeg Map');
IF CountDMapSlots(UPt) > 0 THEN
BEGIN
PrintTitleBlk('CONST DSeg Map Begins Here (LL at 0010)',7);
K := TabStop;
TabStop := 42;
NextLL := Upt^.UHDsT;
Base := NextLL;
C := AddrDMapTab(UPt);
J := CountDMapSlots(UPt)-1;
CONSTHeadings;
FOR I := 0 TO J DO WITH C^.DSegMap[I] DO
BEGIN
PageOverFlow(7,ConstHeadings);
PrintCodeBytes(UPt,8,8,Base);
SetCol(TabStop);
PutTxt('Owned By ');
IF DSegOwn <> $0000
THEN PutTxt(NameOfObject(UPt,DSegOwn))
ELSE PutTxt('???');
NewTxtLine;
END; { FOR }
TabStop := K;
END; { IF }
NoteEnd;
END; { FormatTypedConMap }
{$F+}
PROCEDURE VARHeadings;
BEGIN
SetCol(8); PutTxt('Entry Turbo Segmt Usage Usage');
SetCol(8); PutTxt('Offset Work? Bytes ??? ??? ');
SetCol(8); PutTxt('------ ----- ----- ----- -----');
END; {VARHeadings}{$F-}
PROCEDURE FormatGlobalVarMap(U : UnitHeadPtr); {.CP42}
VAR Base, I : Word; SaveTab : Integer;
BEGIN
NoteBegin('Formatting Global VAR Map');
SaveTab := TabStop;
TabStop := 42;
IF U^.UHDsV <> U^.URULt THEN
BEGIN
I := 0;
PrintTitleBlk('Global VAR DSeg Map Begins Here (LL at 0012)',5);
VARHeadings;
NextLL := U^.UHDsV;
Base := NextLL;
WHILE U^.URULt > NextLL DO
BEGIN
PageOverFlow(5,VARHeadings);
PrintCodeBytes(U,8,8,Base);
SetCol(TabStop);
CASE I OF
0: PutTxt('Owner: INTERFACE');
1: PutTxt('Owner: IMPLEMENTATION');
ELSE PutTxt('Owner: ???')
END; {CASE}
Inc(I);
SetCol(1);
END;
END;
TabStop := SaveTab;
NoteEnd;
END; {FormatGlobalVarMap}
PROCEDURE FormatUnitDonorList(U : UnitHeadPtr); {.CP22}
VAR UCP : UnitDonorPtr; UNE : LL;
BEGIN
NoteBegin('Formatting Donor Unit List');
SetCol(1);
IF U^.USRCF <> NextLL THEN WITH U^ DO
BEGIN
PrintTitleBlk('Code/Data Donor Units Listed Here (LL at 0014)',2);
UCP := UnitDonorPtr(PtrAdjust(U,U^.URULt));
WHILE NextLL <> USRCF DO WITH UCP^ DO BEGIN
IF LinesRemaining < 2 THEN NewTxtPage;
UNE := FormLL(U,UCP)+SizeOf(UDExxx) + 1 + Ord(UDEnam[0]);
PrintWd(U,'Offset='+HexW(NextLL-URULt)+', TURBO Work?');
PrintBytes(U,1+Ord(UDEnam[0]),9);
SetCol(TabStop);
PutTxt('=''' + UDEnam + '''');
SetCol(1);
UCP := UnitDonorPtr(PtrAdjust(U,UNE));
END;
END;
NoteEnd;
END; {FormatUnitDonorList}
PROCEDURE FormatSourceFileList(U : UnitHeadPtr); {.CP52}
VAR S : SrcFilePtr; SLL : LL; StA : String[10]; StW : String[4];
OldTabStop : Integer;
PROCEDURE FormatTime(Time : Word);
VAR I : Integer;
BEGIN
Str( Time SHR 11:2,StA); StA := StA + ':';
Str((Time AND 2047) SHR 5:2,StW);StA := StA + StW + ':';
Str((Time AND 31) SHL 1:2,StW); StA := StA + StW;
FOR I := 1 TO 7 DO IF StA[I] = ' ' THEN StA[I] := '0';
END; {FormatTime}
PROCEDURE FormatDate(Date : Word);
VAR I : Integer;
BEGIN
Str((Date AND 511)SHR 5:2,StA); StA := StA + '/';
Str( Date AND 31:2,StW); StA := StA + StW + '/';
Str((Date SHR 9) + 1980:4,StW); StA := StA + StW;
FOR I := 1 TO 4 DO IF StA[I] = ' ' THEN StA[I] := '0';
END; {FormatDate}
BEGIN {FormatSourceFileList}
NoteBegin('Formatting Source File List');
OldTabStop := TabStop;
TabStop := 48;
PrintTitleBlk('Source File List Begins Here (LL at 0016)',5);
SLL := U^.UDBTS;
S := SrcFilePtr(PtrAdjust(U,NextLL));
WHILE SLL <> NextLL DO WITH S^ DO BEGIN
IF LinesRemaining < 5 THEN NewTxtPage;
PrintSoloByte(U,'Flag');
PrintWd(U,'TURBO Work?');
CASE SrcFlag OF
$03,$04: { .PAS OR .INC file }
BEGIN
FormatTime(SrcTime); PrintWd(U,'Time-Stamp='+StA);
FormatDate(SrcDate); PrintWd(U,'Date-Stamp='+StA);
END
ELSE BEGIN
PrintBytes(U,4,9);SetCol(TabStop);
PutTxt('NO Time, Date-Stamps');
END
END; { CASE }
PrintBytes(U,1+Ord(SrcName[0]),13);
SetCol(TabStop);PutTxt('='''+SrcName+'''');
SetCol(1);
S := AddrNxtSrc(U,S);
END;
TabStop := OldTabStop;
NoteEnd;
END; {FormatSourceFileList}
PROCEDURE FormatTraceTable(U : UnitHeadPtr); {.CP41}
VAR T : TraceRecPtr; S,X : String[6]; I,J, Limit : Word;
Cp : CSegMapTabPtr; Cx : Integer;
BEGIN
NoteBegin('Formatting Trace Table');
SetCol(1);
T := AddrTraceTab(U);
IF T <> Nil THEN
BEGIN
Limit := GetTrExecSize(T);
Cp := AddrCMapTab(U);
Cx := 0;
PrintTitleBlk('Trace Table for Turbo Debugger is Next (LL at 0018)',
7+(Limit SHR 3));
WHILE T <> Nil DO WITH T^ DO BEGIN
Limit := GetTrExecSize(T);
IF LinesRemaining < (7+Limit SHR 3) THEN NewTxtPage;
IF TrName <> 0
THEN PrintLL(U,NameOfMethod(U,TrName))
ELSE PrintWd(U,'Unit Init Code Block');
PrintWd(U,'Src File: "' + AddrSrcTabOff(U,TrFill)^.SrcName + '"');
Str(T^.TrPfx,S); PrintWd(U,S+' Data bytes precede Code');
Str(T^.TrBeg,S); PrintWd(U,'BEGIN Stmt at Line # '+S);
Str(T^.TrLNos,S); PrintWd(U,S+' Lines of Code to Execute');
I := 1;
WHILE I <= Limit DO BEGIN
J := I + 7;
IF J > Limit THEN J := Limit;
Str(I-1+TrBeg,S); Str(J-1+TrBeg,X);
PrintBytes(U,J+1-I,8);
SetCol(TabStop);
PutTxt('Code Bytes in Lines '+S+' Thru '+X);
NewTxtLine;
I := J + 1;
END;
T := AddrNxtTrace(U,T);
NewTxtLine;
END;
END;
NoteEnd;
END; {FormatTraceTable}
PROCEDURE FormatEndNonCode(U : UnitHeadPtr); {.CP05}
BEGIN
PrintTitleBlk('End Non-Code Part Of Unit (LL at 001A)',0);
BoundaryAlign(U);
END; {FormatEndNonCode}
PROCEDURE FormatObjectCode(UH : UnitHeadPtr); {.CP06}
VAR HexOff : Word;
VAR PM : CSegMapTabPtr; MyFil, MyOrg, MyEnd, MyTrc : LL;
SP : SrcFilePtr; R : ReloListPtr;
CMaps, CXs, I, J : Integer; SaveTab : Word; SF : Byte;
PROCEDURE DisplayCode(U : UnitHeadPtr; Count: Word;TrcNdx:LL);
PROCEDURE DisplayCodeLine(VAR P : ObjArg); {.CP20}
BEGIN
WITH P DO WHILE Lim > 0 DO BEGIN
UnAssemble(U,P);
NextLL := Locn;
PrintOffset(HexOff);
SetCol(16); PutTxt(Code);
SetCol(39); PutTxt(Mnem);
SetCol(55); PutTxt(Opr1);
IF Length(Opr2) > 0 THEN PutTxt(','+Opr2);
IF Length(Opr3) > 0 THEN
BEGIN
IF Opr3[1] <> ';'
THEN PutTxt(',')
ELSE PutTxt(' ');
PutTxt(Opr3)
END;
NewTxtLine;
END;
END; {DisplayCodeLine}
VAR P : ObjArg; I,J,K,L:Word; Limit, IP : LL; {.CP42}
T : TraceRecPtr; S : String[6];
BEGIN {DisplayCode}
IF Count > 0 THEN
BEGIN
Limit := Count;
IP := NextLL;
P.TCpu := C086;
T := AddrTraceTab(U);
IF (T = Nil) OR (TrcNdx = $FFFF) THEN
BEGIN
P.Lim := Limit;
P.Obj := IP;
DisplayCodeLine(P);
IP := P.Obj;
END ELSE
BEGIN
T := Ptr(Seg(T^),Ofs(T^)+TrcNdx);
L := T^.TrBeg;
K := GetTrExecSize(T);
P.Obj := IP;
I := 1;
WHILE I <= K DO BEGIN
IF T^.TrExec[I] = $80 THEN Inc(I);
P.Lim := T^.TrExec[I];
IF P.Lim > 0 THEN
BEGIN
PutTxt('; ------------> Code From Line: ');
Str(L,S);
PutTxt(S);
IF I = 1 THEN PutTxt(' ("BEGIN" Statement)') ELSE
IF I = K THEN PutTxt(' ("END" Statement)');
NewTxtLine;
DisplayCodeLine(P);
END;
Inc(L); Inc(I);
END;
IP := P.Obj;
END;
NextLL := IP;
END;
END; {DisplayCode}
PROCEDURE UnAssembleCode(Hash : LL;SF : Byte; {.CP31}
Org, Limit : Word;
TrcNdx : LL;Comment:Boolean);
VAR Stopper : LL;
BEGIN
IF LinesRemaining < 4 THEN NewTxtPage;
Stopper := Limit-Org;
IF NextLL > Org THEN Stopper := Limit-NextLL;
IF (Stopper > 0) THEN
BEGIN
IF Comment THEN {Allow Remarks}
BEGIN
SetCol(7); PutTxt('Code For ');
IF SF < $05
THEN
IF Hash <> $FFFF
THEN PutTxt('PROC "'+NameOfMethod(UH,Hash)+'"')
ELSE PutTxt('Unit Initialization')
ELSE
IF Hash <> $FFFF
THEN PutTxt('PUBLIC "'+NameOfMethod(UH,Hash)+'"')
ELSE PutTxt('PRIVATE or Un-named PUBLIC');
PutTxt(' starts at '+HexW(NextLL));
NewTxtLine;NewTxtLine;
END;
IF DisAssembly
THEN DisplayCode(UH,Stopper,TrcNdx)
ELSE PrintCodeBytes(UH,Stopper,16,HexOff);
NewTxtLine;NewTxtLine;
END;
END; {UnAssembleCode}
PROCEDURE UnAssembleData(PMRefs : PMapRefRec; SF: Byte); {.CP13}
BEGIN
SetCol(7);
IF SF <> $05
THEN PutTxt('(Preamble Data Begins at ')
ELSE PutTxt('(PRIVATE Code or Data Begins at ');
PutTxt(HexW(NextLL)+')');
NewTxtLine;NewTxtLine;
IF SF <> $05
THEN PrintCodeBytes(UH,PMRefs.PmEntP-NextLL,16,HexOff)
ELSE UnAssembleCode(PMRefs.PmDirN,SF,NextLL,PMRefs.PmEntP,$FFFF,False);
NewTxtLine;NewTxtLine;
END; {UnAssembleData}
BEGIN {FormatObjectCode} {.CP46}
NoteBegin('Formatting CODE Segments');
PM := AddrCMapTab(UH);
IF UH^.UHCsg < UH^.UHDsT THEN WITH PM^, PMapP^, PMapC^ DO
BEGIN
SaveTab := TabStop;
TabStop := 55;
R := AddrFixUps(UH);
PrintTitleBlk('Object Code Begins Here',0);
CMaps := NMapC; { Code Segments }
CXs := NMapP-1; { Procs }
IF (PMRefs[CXs].PmEntP = $FFFF) { remove unused init proc }
THEN Dec(CXs);
I := 0; { Track PMRefs Table }
J := 0; { Track CSeg Map Table }
REPEAT {.CP30}
NewTxtLine;
WHILE PMRefs[I].PmNdxC < J DO Inc(I);
MyOrg := CmRefs[J].CmSegL; { Segment Load Point }
MyEnd := MyOrg + CmRefs[J].CmSegS; { Next Segment Start }
MyFil := CmRefs[J].CmNdxF; { Segment Source Fil }
MyTrc := CSegMap[CmRefs[J].CmNdxC].CSegTrc;
SP := AddrSrcTabOff(UH,MyFil);
PutTxt('---- Code Segment at '+HexW(NextLL)+' Found In "');
PutTxt(SP^.SrcName+'"');
NewTxtLine; NewTxtLine;
HexOff := NextLL;
SF := SP^.SrcFlag;
IF (PMRefs[I].PmEntP <> NextLL)
THEN UnAssembleData(PMRefs[I],SF);
WHILE (I <= CXs) AND (PMRefs[I].PmNdxC = J) DO BEGIN
WITH PmRefs[I] DO
UnAssembleCode(PmDirN,SF,PmEntP,PmEntP+PmSizP,MyTrc,True);
Inc(I);
END;
Inc(J);
UNTIL (J = CMaps);
TabStop := SaveTab;
SetCol(1);PutTxt('---- END OF ALL OBJECT CODE');
NewTxtLine;NewTxtLine;
BoundaryAlign(UH);
END;
NoteEnd;
END; {FormatObjectCode}
PROCEDURE FormatDataAreas(UH : UnitHeadPtr); {.CP37}
VAR PD : DSegMapTabPtr; SaveTab : Word; T : TypePtr;
I, MapEnd : Word; EndLL : LL;
BEGIN
NoteBegin('Formatting CONST Data Segments');
SaveTab := TabStop;
EndLL := NextLL + UH^.ULTCon;
IF EndLL <> NextLL THEN
BEGIN
PrintTitleBlk('CONST Data Segments Follow',5);
WITH UH^ DO MapEnd := (UHDsV-UHDsT) DIV SizeOf(DSegMapRec);
BEGIN
PD := AddrDMapTab(UH);
FOR I := 0 TO MapEnd-1 DO WITH PD^.DSegMap[I] DO
BEGIN
NewTxtLine;
SetCol(7);
IF DSegOwn <> 0 THEN
BEGIN
T := TypePtr(PtrAdjust(UH,DSegOwn));
PutTxt('VMT Skeleton for "');
PutTxt(AddrDict(UH,T^.ObjtName)^.DSymb+'"');
END ELSE
PutTxt('Data Area Begins at '+HexW(NextLL));
SetCol(1);
NewTxtLine;
PrintBytes(UH,DSegCnt,16);
SetCol(1);
END; {FOR}
END; {WITH}
NewTxtLine;PutTxt('---- END OF ALL DATA SEGMENTS');
NewTxtLine;NewTxtLine;
END; {IF}
TabStop := SaveTab;
BoundaryAlign(UH);
NoteEnd;
END; {FormatDataAreas}
{$F+}
PROCEDURE ReloHeadings; {.CP06}
BEGIN
SetCol(7); PutTxt('Un Fl Map E-Adr Patch : Ptch Type Refers');
SetCol(7); PutTxt('it ag Ofset Ofset Ofset : Size Map To Unit');
SetCol(7); PutTxt('-- -- ----- ----- ----- : ---- ---- --------');
END; {ReloHeadings} {$F-}
PROCEDURE FormatReloList(UH : UnitHeadPtr); {.CP02}
TYPE Remark = String[8]; T4 = String[4]; T8 = String[8];
PROCEDURE ReloIdentify( R : ReloListEntry; {.CP17}
VAR S2, S1 : T4; VAR S3 : T8);
VAR PU : UnitDonorPtr;
BEGIN {ReloIdentify}
CASE (R.RloFlg SHR 6) AND $3 OF
0: S1 := 'PROC'; 1: S1 := 'CSeg';
2: S1 := 'DATA'; 3: S1 := 'CONS';
END;
CASE (R.RloFlg SHR 4) AND $3 OF
0: S2 := 'WORD'; 1: S2 := 'WD+E';
2: S2 := 'SEG '; 3: S2 := 'FPTR';
END;
IF (R.RloFlg AND $F) <> 0 THEN
BEGIN S1 := '??? '; S2 := '????'; END;
PU := UnitDonorPtr(PtrAdjust(UH,UH^.URULt+R.RloDnr));
S3 := PU^.UDENam;
END; {ReloIdentify}
VAR R : ReloListPtr; T : TypePtr; PU : UnitDonorPtr; {.CP47}
PC : CSegMapTabPtr; PD : DSegMapTabPtr; S1,S2:T4;S3 : T8;
I, J, K, MapEnd : Word; EndS, EndLL : LL; SaveTab : Word;
BEGIN
NoteBegin('Formatting Relo Lists');
SaveTab := TabStop;
TabStop := 33;
EndLL := NextLL + UH^.ULPtch;
IF EndLL <> NextLL THEN WITH UH^ DO
BEGIN
PrintTitleBlk('Relocation Data Table Follows',7);
SetCol(1);
J := 0;
R := ReloListPtr(PtrAdjust(UH,NextLL));
IF UHCsg < UHDsT THEN
BEGIN
PC := AddrCMapTab(UH);
MapEnd := (UHDsT-UHCsg) DIV SizeOf(CSegMapRec);
FOR I := 0 TO MapEnd-1 DO WITH PC^.CSegMap[I] DO
IF CSegRel <> 0 THEN
BEGIN
SetCol(1);
IF LinesRemaining < 9 THEN NewTxtPage
ELSE NewTxtLine;
SetCol(7);
PutTxt('Relocation Data For CSeg Map Entry at ');
PutTxt(HexW(I*SizeOf(CSegMapRec)+UHCsg));
PutTxt(' (Segment Load Addr = ');
EndS := PMapC^.CmRefs[i].CmSegL;
PutTxt(HexW(EndS)+')');
EndS := EndS + PMapC^.CmRefs[i].CmSegS;
SetCol(1);NewTxtLine;
ReloHeadings;
FOR K := PMapC^.CmRefs[i].CmNdxR TO PMapC^.CmRefs[i].CmCntR DO
BEGIN
PageOverFlow(2,ReloHeadings);
ReloIdentify(R^.ReloList[K],S1,S2,S3);
PrintBytes(UH,8,8);
SetCol(TabStop); PutTxt(S1);
SetCol(TabStop+5);PutTxt(S2);
SetCol(TabStop+10);PutTxt(S3);
Inc(J);
END; {WITH}
END; {FOR}
END; { IF CSeg Map non-Empty }
IF UHDsT < UHDsV THEN {DSeg Map non-Empty} {.CP49}
BEGIN
PD := AddrDMapTab(UH);
K := NextLL;
NewTxtLine;NewTxtLine;
BoundaryAlign(UH);
IF K <> NextLL THEN Inc(J);
MapEnd := (UHDsV-UHDsT) DIV SizeOf(DSegMapRec);
EndS := (EndS + $F) AND $FFF0;
FOR I := 0 TO MapEnd-1 DO WITH PD^.DSegMap[I] DO
IF DSegRel <> 0 THEN
BEGIN
SetCol(1);
IF LinesRemaining < 9 THEN NewTxtPage
ELSE NewTxtLine;
SetCol(7);
PutTxt('Relocation Data For CONST DSeg Map Entry at ');
PutTxt(HexW(I*SizeOf(DSegMapRec)+UHDsT));
PutTxt(' (Segment Load Addr = ');
PutTxt(HexW(EndS)+')');
EndS := EndS + DSegCnt;
SetCol(1);NewTxtLine;
ReloHeadings;
K := 0;
WHILE K < (DSegRel DIV SizeOf(ReloListEntry)) DO
BEGIN
PageOverFlow(2,ReloHeadings);
ReloIdentify(R^.ReloList[J],S1,S2,S3);
PrintBytes(UH,8,8);
SetCol(TabStop); PutTxt(S1);
SetCol(TabStop+5);PutTxt(S2);
SetCol(TabStop+10);PutTxt(S3);
Inc(J);
Inc(K);
END; {WHILE}
END; {FOR}
END; { IF DSeg Map non-Empty }
NewTxtLine;NewTxtLine;
PutTxt('---- END OF ALL RELOCATION TABLES');
NewTxtLine;NewTxtLine;
END; {IF Relo List non-Empty}
TabStop := SaveTab;
BoundaryAlign(UH);
NoteEnd;
END; {FormatReloList}
PROCEDURE DocumentUnit(P : UnitHeadPtr); {.CP18}
BEGIN
FormatHeader(P);
SurveyDictionary(P); { Ident Dictionary Entries }
FormatDictionary(P); { PRINT the Dictionary }
XrefMaps(P); { Cross-index Map Tables }
FormatProcMap(P,AddrPMapTab(P)^,NMapP); { PRINT the PROC Map }
FormatCSegMap(P,PMapP^,NMapP,PMapC^,NMapC); { PRINT the CSeg Map }
FormatTypedConMap(P); { PRINT the CONST Map }
FormatGlobalVarMap(P); { PRINT the VAR Map }
FormatUnitDonorList(P); { PRINT the Donor Unit Tab }
FormatSourceFileList(P); { PRINT the Source Files }
FormatTraceTable(P); { PRINT the Trace Table }
FormatEndNonCode(P); { PRINT separator }
FormatObjectCode(P); { PRINT CODE Segments }
FormatDataAreas(P); { PRINT CONST Segment Data }
FormatReloList(P); { PRINT LINKER Relo Data }
END; {DocumentUnit}
VAR i,j : integer; P : UnitHeadPtr; Module:String[8]; c:char; {.CP35}
BEGIN { Main Program }
ClrScr;
Write('Enter Name of Unit to Document: ');ReadLn(Module);
i := WhereX; j := WhereY;
REPEAT
GoToXY(i,j);ClrEol;
Write('Do You Want Dis-Assembly of Code? [Y|N] ');
ReadLn(c);
UNTIL UpCase(c) IN ['Y','N'];
DisAssembly := UpCase(c) = 'Y';
FOR I := 1 TO Length(Module) DO Module[I] := UpCase(Module[I]);
TabStop := 36;
InitJobUnit(Module);
IF BufPtrJob <> Nil THEN
BEGIN
P := UnitHeadPtr(BufPtrJob);
Write('Unit Header="');
FOR i := 0 TO 3 DO WITH P^ DO Write(FilHd[i]);
WriteLn('"');
WriteLn('Unit Name="',DictHeadPtr(PtrAdjust(P,P^.UdirE))^.DSymb,'"');
OpenTxt(Module+'.LST',60,80);
PutTxt('=============================================='); NewTxtLine;
PutTxt('* Unit Header For: "'
+ DictHeadPtr(PtrAdjust(P,P^.UdirE))^.DSymb + '"'); NewTxtLine;
PutTxt('=============================================='); NewTxtLine;
NextLL := 0;
DocumentUnit(P); NewTxtPage;
CloseTxt;
END ELSE
WriteLn('File "',module,'.TPU" Not Found!');
DropJobUnit;
END.